﻿module Coroutine_Parser

open System

type  Prg = Prg of P
and   P   = PS of unit | Id of string


type Eventually<'a, 's> = 's -> Step<'a, 's>
and Step<'a, 's> = 
  | Done of 'a * 's 
  | Yield of Eventually<'a,'s> * 's
  | Fail

type State = { input : string; mutable count : int; mutable bind_count : int}
  with member this.InputLength = this.input.Length

module  Eventually =
  let rec bind (p :Eventually<'a,'s>) (k:'a ->Eventually<'b,'s>) : Eventually<'b,'s> =
    fun s ->
      match p s with
      | Done  (x,s')  -> Yield(k x, s')
      | Yield (p',s') -> Yield(bind p' k,s')
      | Fail -> Fail

  let result x s = Done (x, s)
  let zero = Fail
  let delay f = bind (result ()) f


type EventuallyBuilder() =
  member this.Bind(p, k)      = Eventually.bind p k
  member this.Return(x)       = Eventually.result x
  member this.ReturnFrom(s)   = s
  member this.Zero ()         = Eventually.zero
  member this.Delay(s)        = this.Bind(this.Return(), s)
  member this.Run(s)          = s

let parser = EventuallyBuilder()
let parse (p: Eventually<'a, State>) s = p s
let fail : Eventually<'a, State> = fun s -> Fail
let yield_ : Eventually<'a, State> = fun s -> Yield((fun s -> Done((),s)),s)

let begin_ : Eventually<'a, State> = fun s -> s.bind_count <- s.bind_count + 1
                                              Done((),s)
let adjuct_couters_ : Eventually<'a, State> = fun s -> s.bind_count <- s.count
                                                       Done((),s)

let rec (<+>) (p:Eventually<'a,'s>) (q:Eventually<'b,'s>) : Eventually<Choice<'a, 'b>,'s> =
  fun s ->

  match p s, q s with
    |Done (x, s1), _ -> Done (Choice1Of2 x, s1)  
    |_, Done (y, s2) -> Done (Choice2Of2 y, s2)
    |Yield(k1, s), Yield(k2, _) -> Yield(k1 <+> k2, s)
    |Yield(k1, s1), Fail -> Yield(k1 <+> (fun _ -> Fail), s1)
    |Fail, Yield(k2, s2) -> Yield((fun _ -> Fail) <+> k2, s2)
    |Fail, Fail -> Fail
      

let test1 : Eventually<'a, State>  = 
  parser{    
    return()
  }
let test2 : Eventually<'a, State>  = 
  parser{
    return()
  }


let rec test : Eventually<'a, State>  = 
  parser{
    //do! test1
    //do! test2
    do! begin_
    let! res = test1 <+> test2 <+> test
    do! adjuct_couters_
    return()
  }

let state = { input = ""; count = 0 ; bind_count = 0} 
let rec eval test s =
    match parse test s with
    Fail ->  failwith "Parse Fail!"
    |Yield(k, s) -> eval k s
    |Done(res, s) -> res

do eval test state |> ignore


//let item : CoroutineP<char,State> = 
//  fun s ->
//    match s.input with
//    | "" -> Fail
//    | s' -> Done (s'.[0], {s with input = s'.Substring(1)})
//
//let sat p =
//  parser{
//    let! s = item
//    if p s then 
//      return s
//  }
//
//let lift_1 f s1 =
//  parser{
//    let! x1 = s1
//    return f x1
//  }
//
//let ignore_ s = lift_1 (fun x -> ()) s
//
//let isSpace = fun c -> c = ' '
//let return_ s = parser{ return s }
//
//let v (p : CoroutineP<'a,State>) (q : CoroutineP<'a,State>) : CoroutineP<'a,State> = 
//  fun s ->
//    match p s with
//    Fail -> q s
//    | res -> res
//
//let rec many p =
//  v (many1 p) (return_ "")
//
//and many1 p =
//  parser{
//    let! x = sat p
//    let! xs = many p
//    return (string x) + xs
//  }
//
//
//let char x = sat ((=) x)
//
//let token p =
//  parser{
//    let! v = p
//    return v
//  }
//
//
//let rec string s =
//  parser{
//    if s = "" then return ()
//    else
//      let x, xs = s.[0], s.Substring(1)
//      do! char x |> ignore_
//      do! string xs
//  }
//
//let symbol s = token (string s)
//
//let idbody =
//  parser{
//    let! body = many1 ((fun c_list c -> 
//                          [for c' in c_list -> c' <> c] |> Seq.exists(fun res -> res = false) |> not)
//                        [' '; ';';'(';'[';')';']';',';'{';'}'])
//    return body
//  }
//
//
//let rec s : CoroutineP<S, State> =
//  parser{
//    let! s = s <+> symbol "xxx"
//    
//    match s with
//    |Choice1Of2 r  -> return S.S ()
//    |Choice2Of2 id -> return S.Id "xxx"
//  }
//
//
//let state = { input = "xxxxxxx"; count = 0 } 
//let rec eval =
//  match parse s state with
//  Fail ->  failwith "Parse Fail!"
//  |Yield(k, s1) -> parse k s1
//  |Done(res, s1) -> parse s state